home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 005 / epistat.arc / HISTOGRM.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1983-08-18  |  4.8 KB  |  95 lines
  1. 1  REM          HISTOGRAM GRAPHING - HIRES SCREEN AND PRINTER
  2. 2  REM              Written by Tracy L. Gustafson, M.D.,
  3. 3  REM              Round Rock, Texas. Version 2.0, 1983
  4. 5  DEF SEG=&H40
  5. 6  A=PEEK(&H17): IF NOT(A AND &H20) THEN POKE &H17,(A AND (NOT &H20)) OR &H20
  6. 8  DEF SEG: CLEAR: OPTION BASE 1: DEFINT A-C,I-L,N,T,Z: DEFSTR D
  7. 10  SCREEN 0,0: WIDTH 80: COLOR 7,0,1: KEY OFF: FOR Z=1 TO 10: KEY Z,"": NEXT
  8. 12  CLS: PRINT TAB(22);"KEY";STRING$(28,205);"CLOSE"
  9. 15  PRINT TAB(22);"OPEN HISTOGRAM GRAPHING PROGRAM OPEN"
  10. 18  PRINT TAB(22);"SCREEN";STRING$(28,205);"LOAD"
  11. 20  PRINT: AP=CSRLIN: PRINT TAB(10);"What is the name of the DATAFILE you wish to analyze?"
  12. 30  LOCATE AP,65: INPUT "",FILE$: ON ERROR GOTO 630
  13. 40  OPEN FILE$ FOR INPUT AS #1: INPUT #1, A,C
  14. 50  DIM D(A,C),CS(A,C),N$(A),X(A),X2(A),T(A),SD(A),MD(A),CT(1),EXL(1),BP(201)
  15. 60  FOR T=1 TO A: INPUT #1, T(T): NEXT
  16. 70  FOR T=1 TO A: FOR Z=1 TO C: INPUT #1, D(T,Z): NEXT: NEXT
  17. 80  FOR T=1 TO A: FOR Z=1 TO T(T): INPUT #1, CS(T,Z): NEXT: NEXT
  18. 90  FOR T=1 TO A: INPUT #1, N$(T),X(T),X2(T),MD(T),SD(T): NEXT: CLOSE #1
  19. 100  PRINT: PRINT: PRINT TAB(8);: INPUT "What is the SAMPLE NUMBER of the group you want to graph?   ",NS
  20. 105  IF NS>A THEN BEEP: PRINT TAB(20);"This DATAFILE has only";A;"samples.": GOTO 100
  21. 110  CLS: PRINT TAB(25);"HISTOGRAM GRAPHING PROGRAM": PRINT TAB(25);STRING$(26,205): PRINT: AP=CSRLIN
  22. 115  LOCATE 25,1: COLOR 0,7: PRINT "KEY F1 = RETURN";: LOCATE 25,59: PRINT "KEY F10 = PRINT COPY";: COLOR 7,0: LOCATE AP,1
  23. 120  N=T(NS): D1=D(NS,CS(NS,1)): D2=D(NS,CS(NS,N)): FD=ABS(VAL(D2)-VAL(D1))
  24. 130  PRINT TAB(6);"The";N;"VALUES in sample";NS;"range from ";D1;" to ";D2;":"
  25. 140  PRINT TAB(27);"The difference between these values is";FD;"."
  26. 150  PRINT: PRINT TAB(10);: INPUT "What is the name of the FACTOR to be graphed?   ",FCTR$
  27. 160  PRINT TAB(26);"What are the units of ";FCTR$;: INPUT "?   ",FUNIT$
  28. 170  PRINT:PRINT TAB(10);"The maximum number of subintervals I can graph is 60.":PRINT TAB(7);"With this in mind, choose WIDTH of intervals for this graph:"
  29. 180  PRINT: PRINT TAB(13);: PRINT "Enter WIDTH of each cell (in ";FUNIT$;: INPUT "):  ",FU
  30. 185  IF FD/FU>70 THEN BEEP: GOTO 170
  31. 190  LOCATE 22,32: COLOR 23: PRINT "CALCULATING";: COLOR 0
  32. 200  BT=INT(FD/FU)+7: HD=1: CC=1
  33. 210  ERASE CT,EXL: DIM CT(BT),EXL(BT)
  34. 220  EXL(1)=VAL(D1)-3*FU: IF VAL(D1)>=0 AND EXL(1)<0 THEN EXL(1)=0: SNM=FU ELSE SNM=EXL(1)
  35. 222  ENM=EXL(1)+BT*FU
  36. 225  IF ENM>99 THEN HD=HD*10: SNM=SNM/10: ENM=ENM/10: GOTO 225
  37. 230  IF ABS(SNM)<0.1 THEN HD=HD/10: SNM=SNM*10: GOTO 230
  38. 235  IF SNM<-99 THEN HD=HD*10: SNM=SNM/10: GOTO 235
  39. 238  IF EXL(1)<>0 THEN EXL(1)=INT(SNM*10)*(HD/10)
  40. 240  FOR T=1 TO N: VX=VAL(D(NS,CS(NS,T)))
  41. 250  IF VX<EXL(CC) THEN CT(CC)=CT(CC)+1: GOTO 270
  42. 260  CC=CC+1: EXL(CC)=EXL(CC-1)+FU: GOTO 250
  43. 270  NEXT
  44. 275  FOR Z=CC TO BT: EXL(Z)=EXL(Z-1)+FU: NEXT
  45. 280  CMX=1: FOR Z=1 TO BT: IF CT(Z)>CMX THEN CMX=CT(Z)
  46. 285  NEXT
  47. 300  SCREEN 2,1: OUT 985,1: CLS: PRINT TAB(15);"DATAFILE: ";FILE$;TAB(45);"SAMPLE: ";N$(NS)
  48. 305  XUI=20/CMX: CUIX=1: CUI=INT(XUI): IF XUI>5 THEN CUI=5 ELSE IF XUI<1 THEN CUIX=INT(1/XUI+1): CUI=1
  49. 310  LVA=(CMX+1)*CUI/CUIX: LINE(34,171)-(34,171-LVA*8)
  50. 320  FOR Z=1 TO CMX/CUIX: HL=171-Z*8*CUI: LINE (30,HL)-(34,HL): NEXT
  51. 330  NH=0: FOR Z=1 TO CMX/CUIX: HL=22-Z*CUI: NH=NH+CUIX: IF CUI=1 THEN IF Z MOD 2=0 THEN 340
  52. 335  LOCATE HL,1: PRINT USING "###";NH
  53. 340  NEXT
  54. 345  CHI=INT(70/BT): IF CHI>5 THEN CHI=5 ELSE IF CHI<1 THEN CHI=1
  55. 350  LHA=(BT+1)*CHI: LINE (34,171)-(LHA*8+34,171)
  56. 355  ZCHI=5/CHI: IF CHI>3 THEN ZCHI=2
  57. 360  FOR Z=1 TO BT: HL=34+8*CHI*Z
  58. 362  IF Z MOD ZCHI=1 THEN LINE (HL,171)-(HL,175) ELSE LINE (HL,171)-(HL,173)
  59. 365  NEXT
  60. 368  EXLH=EXL(BT)/HD: IF ABS(EXLH)<10 THEN P$="###.##" ELSE P$="###.#"
  61. 370  FOR Z=1 TO BT: IF Z MOD ZCHI<>1 THEN 390
  62. 380  HL=2+CHI*Z: LOCATE 23,HL: PRINT USING P$;EXL(Z)/HD;
  63. 390  NEXT
  64. 400  LOCATE 25,HL/2-5: PRINT FCTR$;"  (";FUNIT$;: IF HD<>1 THEN PRINT " x";: PRINT USING "##^^^^";HD;: PRINT ")"; ELSE PRINT ")";
  65. 405  CHIP=CHI*8
  66. 410  FOR Z=1 TO BT: LLC=34+CHIP*(Z-1): RLC=LLC+CHIP
  67. 420  UC=171-INT(CT(Z)*CUI*8/CUIX): LINE (LLC,171)-(RLC,UC),,BF
  68. 430  NEXT
  69. 450  A$=INKEY$: IF A$="" THEN 450 ELSE IF LEN(A$)=2 THEN IF RIGHT$(A$,1)=CHR$(59) THEN 560 ELSE IF RIGHT$(A$,1)=CHR$(68) THEN 470 ELSE BEEP: GOTO 450 ELSE BEEP: GOTO 450
  70. 470  ON ERROR GOTO 660
  71. 480  OPEN "LPT1:" AS #1: WIDTH #1,255: DEF SEG=&HB800
  72. 490  PRINT #1,CHR$(27)+"@";CHR$(13);CHR$(27)+"3"+CHR$(23);CHR$(27)+"U"+CHR$(1);
  73. 500  FOR Z=0 TO 79: PRINT #1,CHR$(27)+"L"+CHR$(32)+CHR$(3);
  74. 510  FOR AY=1 TO 100: AX=80*AY+Z-80: CC=PEEK(AX): BB=PEEK(8192+AX)
  75. 520  BP(AY)=CC: BP(AY+101)=BB: NEXT
  76. 530  FOR AY=100 TO 1 STEP -1: PRINT #1,STRING$(4,BP(AY+101));STRING$(4,BP(AY));: NEXT
  77. 540  PRINT #1,CHR$(13);CHR$(10);: NEXT
  78. 550  FOR Z=41 TO 26 STEP -1: PLAY "MB L32 N=Z;": NEXT: PLAY "MB L3 N18"
  79. 555  PRINT #1,CHR$(27)+"3"+CHR$(36);CHR$(13);CHR$(12);
  80. 557  PRINT #1,CHR$(27)+"U"+CHR$(0);CHR$(27)+"@";
  81. 560  CLOSE #1: DEF SEG: SCREEN 0,1: COLOR 7,0,1: CLS
  82. 565  PRINT: PRINT: INPUT "  Would you like to draw another HISTOGRAM using the SAME sample?  ",A$
  83. 570  IF A$="y" OR A$="Y" THEN 110 ELSE IF A$="N" OR A$="n" THEN 580 ELSE BEEP: GOTO 560
  84. 580  PRINT: INPUT "  Would you like to draw another HISTOGRAM using a DIFFERENT sample?  ",A$
  85. 590  IF A$="N" OR A$="n" THEN 620 ELSE IF A$="y" OR A$="Y" THEN 600 ELSE BEEP: GOTO 580
  86. 600  PRINT: PRINT TAB(8);:INPUT "Is the sample you want in the current DATAFILE?  ",A$
  87. 610  IF A$="Y" OR A$="y" THEN 100 ELSE IF A$="n" OR A$="N" THEN 8 ELSE BEEP: GOTO 600
  88. 620  END
  89. 630  BEEP: PRINT: IF ERL=40 AND ERR=53 THEN PRINT: PRINT TAB(13); "I cannot find a file by that name on drive "; ELSE 680
  90. 640  IF MID$(FILE$,2,1)=":" THEN DR$=LEFT$(FILE$,2) ELSE DR$="A:"
  91. 650  PRINT DR$: PRINT "Your files are:": FILES DR$+"*.*": RESUME 20
  92. 660  BEEP: IF ERR=27 OR ERR=25 THEN PRINT TAB(5);"The printer is not ready.  Check printer, then hit any key to proceed." ELSE 680
  93. 670  A$=INKEY$: IF A$="" THEN 670 ELSE RESUME 300
  94. 680  ON ERROR GOTO 0
  95.